home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / vocs < prev    next >
Encoding:
Text File  |  1992-01-26  |  5.9 KB  |  229 lines
  1. \  9/13/86 mdh added 'only, 'forth, 'definitions initialization (needed by
  2. \          'FREEZE'.
  3. \ f83 vocabulary stack
  4. \
  5. \ 00001 25-jan-92 mdh    PREVIOUS didn't check for dropping ROOT
  6. \ 00002 26-jan-92 mdh    fixed stack depth when calling ?PAUSE in ID.LIST
  7.  
  8.  
  9.  EXISTS? VOC-LINK  NOT
  10.  .IF    : VOC-LINK  VOCLINK ;   
  11.  .THEN  
  12.  
  13. EXISTS? ROMABLE  NOT
  14. .IF  FALSE CONSTANT ROMABLE 
  15. .THEN
  16.  
  17. EXISTS? WORDS
  18. .IF   ." PLEASE REMOVE WORDS AND VLIST FROM PREVOUIS FILES" CR
  19.  .THEN
  20.  
  21. INCLUDE? ['] JF:UTILITIES
  22.  
  23. \ 40 CONSTANT MAXVOCS
  24. \ : USER-ALLOT  ( BYTES --- )  USER#   +! ;
  25. \ CONTEXT @
  26. \ USER CONTEXT  MAXVOCS CELLS USER-ALLOT
  27. \ CONTEXT !
  28.  
  29.  
  30. ROMABLE 
  31. .IF    ." using ROMABLE definitions of vocabularies " CR
  32. \ Jforth vocabulary structure: ROMABLE 
  33. \   header:
  34. \  ( do-does>:)
  35. \   voc-link@:
  36. \   TO-RAM-VARIABLES@
  37.  
  38. \   BACK-LINK@ :  ( IN RAM ) 
  39. \   voc-latest@ : 
  40.  
  41. : VOCABULARY  CREATE ( --- )  ( NEW-VOC-NAME --IN-- ) 
  42.      HERE  VOC-LINK @ , VOC-LINK ! 
  43.      HERE  RAM-HERE   ,  RAM, 
  44.      0 ( sealed LATEST )  RAM, 
  45.      DOES>  ( <PFA> --- ) CELL+ @ CELL+   CONTEXT ! ; 
  46.  
  47. : VLATEST>VLINK  ( VOC-LATEST@ --- VOC-LINK@ ) CELL- @ CELL-  ;
  48. : VLINK>VLATEST  CELL+ @ CELL+  ;
  49.  
  50. .ELSE   \  ."  using RAM based definition of vocabularies"  CR
  51. \ Jforth vocabulary structure: Ram based: 
  52. \   header:
  53. \   ( do-does>: )
  54. \   voc-link@:
  55. \   voc-latest@ : 
  56.  
  57. : VOCDOES  CELL+ CONTEXT !  ;
  58.  
  59. : VOCABULARY  CREATE ( --- )  ( NEW-VOC-NAME --IN-- ) 
  60.      HERE  VOC-LINK @ , VOC-LINK ! 
  61.      here  ColdVocNFAS ( nfapointer arraybase -- )
  62.      #vocs @ [ 2 cells ] literal *  + ! ( tell cold it should set this place )
  63.      ( if the following cell in the table is non zero from freeze. )
  64.      ( Freeze will fetch the nfa stored here and plunk it in the table )
  65.      ( following the pointer to this address)
  66.      0 ( sealed LATEST ) ,
  67.      1 #vocs +! 
  68.      DOES>  ( <PFA> --- ) VOCDOES  ; 
  69.     ( sets context to point to latest ) 
  70.  
  71. : VLATEST>VLINK  ( VOC-LATEST@ --- VOC-LINK@ )  CELL- ;
  72. : VLINK>VLATEST  CELL+ ;
  73.  
  74. .THEN
  75.  
  76.  
  77. EXISTS? DO-DOES-SIZE NOT
  78. .IF   CREATE DON'T-USE-THIS  UNSMUDGE 
  79.     ' DON'T-USE-THIS  HERE - ABS CONSTANT DO-DOES-SIZE 
  80. .THEN 
  81.  
  82. : VLINK>'  ( VOC-LINK@ --- VOCABULARY'S-CFA )
  83.     DO-DOES-SIZE  - ;
  84.  
  85.  
  86. VOCABULARY ROOT  LATEST  ROOT  CONTEXT @ !  ( WILL SEAL LATER ) 
  87.  
  88. ROOT CONTEXT @ CURRENT !  
  89.  
  90. VOCABULARY FORTH  ' ROOT '>NAME  FORTH CONTEXT @ ! 
  91. ' forth 'forth !
  92.  
  93. : DEFINITIONS  CONTEXT @ CURRENT ! ;
  94. ' definitions  'definitions !
  95.  
  96. : BYE  BYE  ;  ( for going bye-bye ) 
  97.  
  98. : ALSO   ( --- ) ( just makes room )
  99.     CONTEXT DUP CELL+  [ MAXVOCS 1-  CELLS ] LITERAL MOVE ;
  100.  
  101. : ONLY  ( --- )  [ ' ROOT ] LITERAL   '>BODY  CONTEXT
  102.   [ MAXVOCS 1- CELLS ] LITERAL DDUP ERASE + ! ROOT ALSO ROOT ;
  103. ' only 'only !
  104.  
  105. \  seal is'nt right for our voc structure
  106. : SEAL ( --- )   '   '>BODY  CONTEXT [ MAXVOCS CELLS ] LITERAL
  107.     ERASE    CONTEXT  !  ;
  108.  
  109. : PREVIOUS  ( --- )  context cell+ @  \ 00001
  110.   IF
  111.      CONTEXT DUP CELL+ SWAP
  112.      [ MAXVOCS CELL- CELLS ]  LITERAL MOVE
  113.      0  CONTEXT  [ MAXVOCS CELL- CELLS  ] LITERAL  +  !
  114.   THEN  ;
  115.  
  116. \ F83 VOCABULARY ORDER:
  117. \ uses existing search order till all voc found
  118.  
  119. turnkeying? NOT .IF
  120. \ ROOT DEFINITIONS  F83
  121. \ ORDER: is not yet compilable
  122. : ORDER:  ( --- )  (  ";" <VOC> ... <CURRENT> --IN-- )
  123.    0  []  '   >R
  124.    BEGIN    >IN @ BL WORD  $" ;" $=  NOT
  125.    WHILE    >IN !  [] '
  126.    REPEAT   DROP  (  last-voc...top-voc --- ) ( current -r- )
  127.    R> EXECUTE DEFINITIONS   ONLY
  128.    BEGIN    DUP
  129.    WHILE    EXECUTE  ALSO
  130.    REPEAT   DROP  PREVIOUS  ;
  131. .THEN
  132.  
  133. \ example: ORDER: FORTH   ASSEMBLER FORTH EDITOR ;
  134. \ =>  FORTH DEFINITIONS ONLY EDITOR ALSO FORTH ALSO ASSEMBLER
  135. \ ORDER <CR>  CURRENT:  FORTH
  136. \             CONTEXT:  ASSEMBLER FORTH EDITOR ROOT
  137.  
  138. \ ROOT DEFINITIONS
  139.  
  140.  
  141. \ FIG
  142. : VOC-ID.  ( context-pointer --- ) >R  VOC-LINK 
  143.     BEGIN  @ DUP 0=  OVER  VLINK>VLATEST  R@ =  OR
  144.     UNTIL  DUP 0=  ?ABORT" Unknown Voc"
  145.       RDROP  ( VLINK ) VLINK>'   '>NAME  ( ID. )  ID.LIST  ;
  146.  
  147. : ORDER   ( --- )
  148.   CR ." Searching (CONTEXT) : "  $ 16 ( 22 )  LISTINDENT !
  149.   CONTEXT MAXVOCS  CNT>RANGE
  150.   DO           I @  -DUP  0= ?LEAVE  ( SPACE ) VOC-ID.
  151.   CELL +LOOP
  152.   >newline ." Extending (CURRENT) : "  CURRENT @ VOC-ID.
  153.   listindent off   CR ;
  154.  
  155. \ HEX   ROOT ONLY FORTH ALSO ROOT
  156. : FIND-IN   ( adr --- cfa true )  ( ... false ) ( vocabulary -inline--- )  
  157.    INLINE@ @  EXECUTE
  158.    CELL  INLINE+    ( adr old-context )  
  159.    CONTEXT @  (FIND) ;
  160.  
  161. USER SEARCH-CURRENT  FALSE SEARCH-CURRENT ! 
  162. : VOC-FIND  ( $ --- ADR FLAG ) CONTEXT
  163.      BEGIN  DUP @                           ( -- $ lfa prevnfa ) 
  164.      WHILE  ( NOT ZERO ) 2DUP @             ( -- $ lfa $ lfa )  
  165.             (FIND) ?dup
  166.             IF   >r  ( $ VOC@ CFA )  >R 2DROP R> r> EXIT
  167.             ELSE ( $ VOC@ $   ) DROP  CELL+ 
  168.             THEN
  169.      REPEAT ( $ VOC@ ) DROP  SEARCH-CURRENT @
  170.      IF     CURRENT @ (FIND) 
  171.      ELSE  FALSE
  172.      THEN   ;
  173.  
  174. : VOCS  ( --- )
  175.   >newline ." Defined Vocabularies: "  $ 16 ( 22 ) listindent !   VOC-LINK
  176.     BEGIN @ DUP
  177.     WHILE  DUP>r ( 00002 )  VLINK>'  '>NAME  ID.LIST r>
  178.     REPEAT DROP  ORDER  listindent off  ;
  179.  
  180. turnkeying? NOT .IF
  181. \ VLIST -------------------------------------------------------
  182.  
  183. base @
  184. hex
  185. : VLIST ( --- )   0 #WORDS ! >newline  CONTEXT @ @ 
  186.     BEGIN  DUP 
  187.     WHILE
  188.            \ linelimit @ ( C/L )  OUT @ - OVER C@
  189.            \ 01F AND [ 2 CELLS ] LITERAL + <
  190.            \ IF    >r ?pause r> CR
  191.            \ THEN
  192.            \
  193.            DUP>r ( 00002 )  ID.LIST r> \   1 #WORDS +!  SPACE SPACE
  194.            N>LINK @
  195.     REPEAT  DROP   #WORDS @ CR 5 .R ."  words "   ;
  196. : WORDS VLIST ;
  197. base !
  198. .THEN
  199.  
  200. ONLY
  201. ' VOC-FIND is find
  202. ROOT  0 ' FORTH '>NAME N>LINK ! 
  203. FORTH ' ROOT '>NAME  CONTEXT @ ! 
  204. ONLY FORTH 
  205. FORTH DEFINITIONS
  206.  ( SEAL UP THE ROOT VOCABULARY ) 
  207.  
  208. DEFER WHEN-SCANNED 
  209. DEFER WHEN-VOC-SCANNED 
  210.  
  211. : SCAN-VOC  ( VLATEST --- )   @ 
  212.     BEGIN  DUP 
  213.     WHILE  DUP>r ( 00002 ) WHEN-SCANNED  r>
  214.            N>LINK @
  215.     REPEAT  DROP    ;
  216.  
  217. : SCAN-WORDS ( --- )  CONTEXT @ SCAN-VOC ;
  218.  
  219. : SCAN-ALL-VOCS ( --- )  VOC-LINK 
  220.    BEGIN  @ DUP
  221.    WHILE  DUP>r ( 00002 )  WHEN-VOC-SCANNED
  222.           r@     VLINK>VLATEST  SCAN-VOC r>
  223.    REPEAT  DROP   ;
  224.  
  225.  
  226.  
  227.  
  228.  
  229.